home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / oop_tp55.zip / TRIGL.PAS < prev    next >
Pascal/Delphi Source File  |  1990-04-16  |  8KB  |  296 lines
  1. unit Trigl;
  2. interface
  3.  
  4. uses ListObj,CRT;
  5.  
  6. const
  7. MaxGen = 13;
  8.  
  9. var
  10.    PosStats : array[0..MaxGen] of longint;
  11.  
  12. type
  13. String15 = string[15];
  14. MoveArray = array[1..3] of integer;
  15. MoveDirection = (no_move, down, up);
  16. MoveFunc = function( i : integer) : MoveDirection;
  17. MoveFuncPtr = ^MoveFunc;
  18.  
  19. const
  20. MaxNumMove = 18;
  21. LegalMoves : array[1..18] of MoveArray =
  22.              ( (1,2,4),    (1,3,6),    (2,4,7),   (2,5,9),
  23.                (3,5,8),    (3,6,10),   (4,5,6),   (4,7,11),
  24.                (4,8,13),   (5,8,12),   (5,9,14),  (6,9,13),
  25.                (6,10,15),  (7,8,9),    (8,9,10),  (11,12,13),
  26.                (12,13,14), (13,14,15) );
  27.  
  28. type
  29.  
  30. { this would be a great place to have multiple inheritance, what we
  31. really need is an object that acts like both a list and a node }
  32. { best we can do, then is to have a node with a constituent list
  33. property}
  34.  
  35. Triangle = object( Node )
  36.            position : String15;
  37.            Offspring : List;
  38.            Generation : integer;
  39.            constructor Init( APosition : String15; Gen : integer );
  40.            destructor Done;
  41.            procedure ShowPosition;
  42.            procedure ShowWin;
  43.            procedure ShowStats;
  44.            function Heuristic : boolean; virtual;
  45.            function FindWin : boolean;
  46.            function FindChildren : boolean;
  47.            function ValidMove( AMove : integer ) : MoveDirection;
  48.            procedure MovePeg( MoveNumber : integer;
  49.                               Direction : MoveDirection;
  50.                               var NewPosition : String15 );
  51.            procedure GenChild( NewPosition : string15 ); virtual;
  52.            function CheckForWin : boolean;
  53.            end;
  54.  
  55. type
  56. TrianglePtr = ^Triangle;
  57.  
  58. procedure Step;
  59. procedure InitStats;
  60. procedure DisplayPosition( Position : String15; x, y : integer);
  61.  
  62. implementation
  63.  
  64. procedure Step;
  65. var
  66.    Dummy : char;
  67. begin
  68.            Dummy := ReadKey;
  69. end;
  70.  
  71. destructor Triangle.Done;
  72. begin
  73.      FreeMem( @Offspring, sizeof(Offspring) );
  74. end;
  75.  
  76. procedure Triangle.ShowWin;
  77. var
  78.    pTriangle : TrianglePtr;
  79.    i : integer;
  80. begin
  81.      if Generation = 0 then
  82.         begin
  83.         ShowPosition;
  84.         Step;
  85.         end;
  86.      if Offspring.Head <> nil then
  87.         begin
  88.         Offspring.Cursor := Offspring.Head;
  89.         pTriangle := Offspring.GetCursor;;
  90.         pTriangle^.ShowPosition;
  91.         Step;
  92.         pTriangle^.ShowWin;
  93.         end;
  94. end;
  95.  
  96. procedure Triangle.ShowStats;
  97. var
  98.    i : integer;
  99.    t : longint;
  100. begin
  101.      ClrScr;
  102.      t := 0;
  103.      for i := 0 to MaxGen do
  104.          begin
  105.          writeln('Number of generation ', i:2, ' positions: ', PosStats[i]);
  106.          t := t + PosStats[i];
  107.          end;
  108.      writeln;
  109.      writeln('Total number of positions examined: ', t );
  110.      Step;
  111. end;
  112.  
  113. function Triangle.FindWin : boolean;
  114. var
  115.    pTriangle : TrianglePtr;
  116.    WinFlag  : boolean;
  117. begin
  118.      if FindChildren = true then
  119.         begin
  120.         WinFlag := false;
  121.         OffSpring.Cursor := OffSpring.Head; { point at head }
  122.         while (Offspring.FindNextObject = true) and (WinFlag = false) do
  123.               begin
  124.               pTriangle := OffSpring.GetCursor; { copy head }
  125.               WinFlag := pTriangle^.FindWin;  { find if it leads to win }
  126.               if WinFlag = false then  { if it doesn't }
  127.                  begin
  128.                  pTriangle := Offspring.PopFirst;
  129.                  Dispose( pTriangle, Done );
  130.                  end;
  131.               end;
  132.         FindWin := WinFlag;
  133.         end
  134.      else
  135.         begin
  136.         if CheckForWin = true then { This means that the Self triangle is
  137.                                      a winner! }
  138.            begin
  139.            writeln( 'I found a win!');
  140.            ShowPosition;
  141.            FindWin := true;
  142.            end
  143.         else
  144.            begin
  145.            FindWin := false;
  146.            end;
  147.         end;
  148. end;
  149.  
  150. { a triangle node has the ability to find its own children
  151.   if it successfully finds its children, the function returns true.
  152.   if a triangle has no children, then we check to see if a winning
  153.   position has been found. }
  154. function Triangle.FindChildren : boolean;
  155. var
  156.    i : integer;
  157.    vflag : MoveDirection;
  158.    NewPosition : String15;
  159. begin
  160.      FindChildren := false;
  161.      if Heuristic = true then
  162.         for i := 1 to MaxNumMove do
  163.             begin
  164.             vflag := ValidMove(i);
  165.             if vflag <> no_move then
  166.                begin
  167.                Inc(PosStats[Generation+1]);
  168.                MovePeg( i, vflag, NewPosition );
  169.                GenChild(NewPosition);
  170.                FindChildren := true;
  171.                end
  172.             end;
  173. end;
  174.  
  175. function Triangle.Heuristic : boolean;
  176. begin
  177.         Heuristic := true
  178. end;
  179.  
  180. { a triangle knows whether a particular type of move is valid for
  181.   its position.  the function returns NO_MOVE if no move is
  182.   possible, UP if a peg can jump from the 3 position to the 1 position
  183.   (as described in the move array), or DOWN if a peg can jump from
  184.   the 1 to the 3 position. }
  185. function Triangle.ValidMove( AMove : integer ) : MoveDirection;
  186. begin
  187.          if (Position[ LegalMoves[AMove,1] ] = 'X') and
  188.             (Position[ LegalMoves[AMove,2] ] = 'X') and
  189.             (Position[ LegalMoves[AMove,3] ] = 'O') then
  190.             ValidMove := down
  191.          else
  192.             if (Position[ LegalMoves[AMove,1] ] = 'O') and
  193.                (Position[ LegalMoves[AMove,2] ] = 'X') and
  194.                (Position[ LegalMoves[AMove,3] ] = 'X') then
  195.                ValidMove := up
  196.             else
  197.                ValidMove := no_move;
  198. end;
  199.  
  200. { given a type of move and a direction (UP or DOWN), a triangle knows
  201.   how to reflect the move in the Position array, and how to create a
  202.   new Triangle object whose position is the new position, and to
  203.   attach the new Triangle object as a member of Offspring list }
  204. procedure Triangle.MovePeg( MoveNumber : integer; Direction : MoveDirection;
  205.                            var NewPosition : String15 );
  206. var
  207.    pNewTriangle : TrianglePtr;
  208.    c : char;
  209. begin
  210.      NewPosition := Position;
  211.      NewPosition[ LegalMoves[MoveNumber, 2] ] := 'O';
  212.      if Direction = down then
  213.         begin
  214.         NewPosition[ LegalMoves[MoveNumber, 1] ] := 'O';
  215.         NewPosition[ LegalMoves[MoveNumber, 3] ] := 'X';
  216.         end
  217.      else
  218.         begin
  219.         NewPosition[ LegalMoves[MoveNumber, 3] ] := 'O';
  220.         NewPosition[ LegalMoves[MoveNumber, 1] ] := 'X';
  221.         end;
  222. end;
  223.  
  224. procedure Triangle.GenChild( NewPosition : string15 );
  225. var
  226.    pNewTriangle : TrianglePtr;
  227. begin
  228.      New( pNewTriangle, Init( NewPosition, Succ(Generation) ) );
  229.      { if you really want to speed things up, comment out the next line }
  230.      pNewTriangle^.ShowPosition;
  231.  
  232.      Offspring.Prepend( pNewTriangle );
  233.      Offspring.Cursor := OffSpring.Head;
  234. end;
  235.  
  236. constructor Triangle.Init( APosition : String15; Gen : integer );
  237. begin
  238.      Position := APosition;
  239.      Offspring.Init;
  240.      Node.Init( SizeOf( Self ) );
  241.      Generation := Gen;
  242. end;
  243.  
  244. procedure DisplayPosition( Position : String15; x, y : integer);
  245. begin
  246.      gotoXY(x,y);
  247.      writeln( '          ', Position[1]);
  248.      gotoXY(x,y+2);
  249.      writeln( '        ', Position[2], '   ', Position[3] );
  250.      gotoXY(x,y+4);
  251.      writeln( '      ', Position[4], '   ', Position[5],
  252.               '   ', Position[6]);
  253.      gotoXY(x,y+6);
  254.      writeln( '    ', Position[7], '   ', Position[8],
  255.               '   ',  Position[9], '   ', Position[10] );
  256.      gotoXY(x,y+8);
  257.      writeln( '  ', Position[11], '   ', Position[12], '   ',
  258.               Position[13], '   ', Position[14], '   ', Position[15] );
  259. end;
  260.  
  261. procedure Triangle.ShowPosition;
  262. begin
  263.      gotoXY(16,10);
  264.      writeln( 'Generation: ' , Generation:2 );
  265.      DisplayPosition( Position, 16, 12 );
  266. end;
  267.  
  268. function Triangle.CheckForWin;
  269. var
  270.    FirstX : integer;
  271.    SubS   : string;
  272. begin
  273.      FirstX := Pos( 'X', Position );
  274.      SubS := Copy( Position, (FirstX+1), 255 );
  275.      if Pos( 'X', SubS ) = 0 then
  276.         CheckForWin := true
  277.      else
  278.         CheckForWin := false;
  279. end;
  280.  
  281. procedure InitStats;
  282. var
  283.    i : integer;
  284. begin
  285.  
  286. PosStats[0] := 1;
  287. for i := 1 to MaxGen do
  288.     PosStats[i] := 0;
  289. end;
  290.  
  291. begin
  292.  
  293. InitStats;
  294.  
  295. end.
  296.